functor CopyProp (S : COPY_PROP_STRUCTS) : COPY_PROP =
struct
  open S
  
  
  structure Cfg = Cfg
  
  local open Cfg
  in structure Id = Id
     structure Intl = Intl
     structure T = Types
     structure B = Binop
     structure O = Operand
     structure K = Block
     structure S = Structs
     structure J = Transfer
     structure M = Stm
     structure F = Function
     structure P = Program
  end
  
  val tag = !Control.doShowOptVerbose
  fun debugPrint s =
      if tag
      then print s
      else ()
      
  val doAgain = ref false
      
  structure Pool : 
  sig
    datatype t
      = FromStm of M.t
      | FromTransfer of J.t
    
    val add : t -> unit  
    val addStm : M.t -> unit
    val addTransfer : J.t -> unit
    val isEmpty : unit -> bool
    val remove : unit -> t
  end =
  struct
    datatype t
      = FromStm of M.t
      | FromTransfer of J.t
    val all : t list ref = ref []
    
    fun add x = all := x :: (!all)    
    fun addStm s = add (FromStm s)
    fun addTransfer j = add (FromTransfer j) 
    fun isEmpty () =
        case !all
         of [] => true
          | _ => false    
   
    fun remove () =
        case !all
         of [] => raise Fail "compiler bug"
          | x :: xs =>
            let val _ = all := xs
            in  x
            end          
  end
  
  fun takeTransfer j = Pool.addTransfer j
  fun takeStm s = Pool.addStm s
  fun takeStms s = List.app takeStm s
       
  fun takeStmAndJump b =
      case b
       of K.T {name,
              prop,
              stms,
              transfer,
              successors} =>
          let val _ = takeStms stms
              val _ = takeTransfer transfer
          in  ()
          end
          
  fun takeAllStmAndJump bs = List.app takeStmAndJump bs
  
  fun loop (blocks) =
      let fun replaceStm (s, origLine) =
              case s
               of M.Phi {line, dest, src} =>
                  if Counter.equals (origLine, line)
                  then let val new = M.Assign {line = line, dest = dest, src = #operand (hd src), ty = T.Intt}
                           val _ = Pool.addStm new
                       in  new
                       end
                  else s
                | _ => s
          fun replaceStms (s, origLine) =
              let fun doit t =
                      case t
                       of [] => []
                        | x :: xs =>
                          let val new = replaceStm (x, origLine)
                          in  new :: (doit xs)
                          end
              in  doit s
              end
          fun replaceBlock (b, origLine) =
              let fun doit b =
                      case b
                       of K.T {name,
                               prop,
                               stms,
                               transfer,
                               successors} =>
                          K.T {name = name,
                               prop = prop,
                               stms = replaceStms (stms, origLine),
                               transfer = transfer,
                               successors = successors}                          
              in  doit b
              end
          fun replaceBlocks (blocks, origLine) =
              let fun doit bs =
                      case bs
                       of [] => []
                        | x :: xs =>
                          let val new = replaceBlock (x, origLine)
                          in  new :: (doit xs)
                          end
              in  doit blocks
              end
          
          fun deleteAndSubstStm (s, origId, subst) =
              if M.usesId (s, origId)
              then (Pool.addStm s; M.substCopyPropUses (s, subst))
              else if M.isAssignMem s
                   then let val _ = Pool.addStm s
                        in  M.substDest (s, subst)
                        end
                   else s
          fun deleteAndSubstStms (s, origLine, origId, subst) =
              let fun doit t =
                      case t
                       of [] => []
                        | x :: xs =>
                          let val line = M.getLine x
                              val new = if Counter.equals (line, origLine)
                                        then doit xs
                                        else (deleteAndSubstStm (x, origId, subst)) :: (doit xs)
                          in  new
                          end
              in  doit s
              end
          fun deleteAndSubstTransfer (s, origId, subst) =
              if J.usesId (s, origId)
              then (debugPrint "subst id in transfer\n"
                  ; Pool.addTransfer s
                  ; J.substUses (s, subst))
              else s
          fun deleteAndSubstBlock (b, origLine, origId, subst) =
              let fun doit b =
                      case b
                       of K.T {name,
                               prop,
                               stms,
                               transfer,
                               successors} =>
                          K.T {name = name,
                               prop = prop,
                               stms = deleteAndSubstStms (stms, origLine, origId, subst),
                               transfer = deleteAndSubstTransfer (transfer, origId, subst),
                               successors = successors}                          
              in  doit b
              end
          fun deleteAndSubstBlocks (blocks, origLine, origId, subst) =
              let fun doit bs =
                      case bs
                       of [] => []
                        | x :: xs =>
                          let val new = deleteAndSubstBlock (x, origLine, origId, subst)
                          in  new :: (doit xs)
                          end
              in  doit blocks
              end
          fun doItStm s =
              case s
               of M.Phi {line = line1, dest = dest1, src = src1, ...} =>
                  if List.length src1 = 1 andalso O.isVar (#operand (hd src1))
                  then let val _ = debugPrint "one argument Phi function detected\n"
                           val _ = doAgain := true                         
                       in  replaceBlocks (blocks, line1)
                       end
                  else blocks
                | M.Assign {line = origLine, dest = origDest, src = origSrc, ty, ...} =>
                  (case (O.getVar origDest, O.getVar origSrc)
                    of (SOME _, SOME _) =>
                       let val _ = debugPrint "one const assignment detected\n"
                           val _ = doAgain := true
                           val (d1, s1) = (valOf (O.dest origDest), valOf (O.dest origSrc))
                           val new = deleteAndSubstBlocks (blocks, origLine, d1, fn x => if Id.equals (x, d1) then s1 else x)
                       in  new
                       end
                     | _ => blocks)
                | _ => blocks
          fun doit x =
              case x
               of Pool.FromStm s =>
                  let val _ = debugPrint "cook stm starting\n"
                  in  doItStm s
                  end
                | Pool.FromTransfer j => blocks
      in  if Pool.isEmpty ()
          then blocks
          else let val s = Pool.remove ()
                   val new = doit s
               in  loop new
               end
      end
          
  
  fun shrinkFunc f =
      case f
       of F.T {name,
               exit,
                rettype,
                args,
                locals,
                blocks,
                pre,
                post} =>
          let fun doit bs =
                  let val _ = takeAllStmAndJump bs
                      val newBlocks = loop bs
                  in  newBlocks
                  end
              fun repeat bs =
                  let val new = doit bs
                  in  if !doAgain
                      then let val _ = doAgain := false
                               val _ = debugPrint "loop again in copy propogation\n"
                           in  repeat new
                           end
                      else new
                  end
              val newBlocks = repeat blocks
              val new = F.T {name = name,
                exit = exit,
                rettype = rettype,
                args = args,
                locals = locals,
                blocks = newBlocks,
                pre = pre,
                post = post}
              val _ = debugPrint "\noutput the graph after copy propogation\n"
              val _ = if tag
                      then F.toDot (new, "copyProp")
                      else ()
          in  new
          end
  
  fun shrinkProg f =
      case f
       of P.T {structs, gvars, funcs, ...} =>
          let val _ = ()
          in  P.T {structs = structs,
                   gvars = gvars,
                   funcs = List.map shrinkFunc funcs}
          end
  
  fun shrink f=
      let val _ = debugPrint "\ncopy propogation starting\n"
          val new = shrinkProg f
          val _ = debugPrint "\ncopy propogation finished\n"
      in  new
      end
end
